(in-package :licada)

(defun peek-while(stream test method)
  "While the test returns true and the next charater is not null, pass
the next character into method.  Test is a generalized boolean taking
one argument, and method takes one argument.  The last character
peeked is returned"
  (do ((next (peek-char nil stream nil)(peek-char nil stream nil)))
      ((or (null next)(not(funcall test next)))
       next )
    (funcall method (read-char stream nil))))

(defun read-till-string (stream string)
  "Read until you find the string in stream"
  (let ((index 0)
	(len (length string)))
    (peek-while stream
		(lambda (item)
		  (setf index (if (char= item (aref string index)) (+ index 1) 0 ))
		  (not(= index len)))
		(lambda(item)item))))

(defun next-non-white(stream)
  (peek-while stream
	      (lambda (item) (whitespace-char-p item))
	      (lambda (item) item )))
	      
(defun non-comment (next stream)
  "Return true if next does not start a comment and false otherwise"
  (if (char= next #\/)
      (let ((peek (peek-char nil stream nil)))
	(cond
	  ((char= peek #\/)(read-line stream nil) nil )
	  ((char= peek #\*)(read-till-string stream "*/") (read-char stream) nil)
	  (t t)))
      t ))

(defvar lcase-range (cons (char-int #\a)(char-int #\z)))
(defvar ucase-range (cons (char-int #\A)(char-int #\Z)))
(defvar num-range (cons (char-int #\0)(char-int #\9)))
(defvar alnum-ranges (list lcase-range ucase-range num-range))
(defvar al-ranges (list lcase-range ucase-range))
(defvar num-ranges (list num-range))

(defun in-ranges (num range-list )
  (dolist (range range-list)
    (when (and (>= num (car range))
	      (<= num (cdr range)))
      (return-from in-ranges t)))
  nil )
		   
(defun token-beginning-p(item)
  (if (or(char= item #\_)
	 (in-ranges (char-int item) al-ranges)
	 (char= item #\#))
      t
      nil ))

(defun token-middle-p(item)
  (if (or (char= item #\_)
	  (in-ranges (char-int item) alnum-ranges))
      t
      nil ))

(defun next-cpp-token(stream)
  (let ((next (do ((next (next-non-white stream) (next-non-white stream)))
		  ((or(null next) (non-comment next stream))
		   next ))))
    (unless (null next)
      (read-char stream) ;;discard result
       (with-output-to-string (retval)
	(write-char next retval)
	(when (token-beginning-p next)
	  (peek-while stream
		      (lambda (item)
			(token-middle-p item))
		      (lambda (item)
			(write-char item retval))))))))

;There could be a large list of callbacks here.
;I implemented what I need right now
(defmethod on-begin-file(item fname)
  "Callback when a file is started")

(defmethod on-begin-enum(item name)
  "Called when a enum is opened")

(defmethod on-end-enum(item)
  "Called when an enum is closed")

(defmethod on-enum-value(item name value)
  "Called when an enumeration value is encountered.
Value may be nil")

(defmethod on-end-file(item)
  "Callback when a file is finished")

(defun token-type( token )
  "Return the either :preprocessor :token or :keyword"
  (unless token
    (return-from token-type nil))
  (let ((first (aref token 0)))
    (cond
      ((char= first #\#) :preprocessor)
      ((token-beginning-p first)
       (cond
	 ((string= token "enum") :enum)
	 (t :token)))
      (t (cond
	   ((char= first #\{) :left-bracket)
	   ((char= first #\}) :right-bracket)
	   ((char= first #\,) :comma)
	   ((char= first #\=) :equal)
	   (t :keyword))))))

(defun tokenize-until(stream test-meth processor)
  (do ((token (next-cpp-token stream) (next-cpp-token stream)))
      ((not(funcall test-meth token))
       token )
    (funcall processor token)))

(defun parse-enum (item stream)
  (on-begin-enum item (next-cpp-token stream))
  (next-cpp-token stream) ;toss the {
  (let ((enum-token))
    (while (not(eq (token-type enum-token) :right-bracket))
      (let ((temp-list))
	(setf temp-list nil)
	(setf enum-token
	      (tokenize-until stream
			      (lambda (tkn)
				(let ((tp (token-type tkn)))
				  (not(or(eq tp :comma)
					 (eq tp :right-bracket)))))
			      (lambda (tkn)
				(push tkn temp-list))))
	(when temp-list
	  (if (cdr temp-list)
	      (on-enum-value item (third temp-list) (first temp-list))
	      (on-enum-value item (first temp-list) nil))))))
  (on-end-enum item)
  (next-cpp-token stream)) ;toss the ;

	  
(defun parse-cpp-file(item file)
  "Parses a cpp file calling various callbacks during the parsing.
Item is user-supplied opaque data, file is a filename"
  (let ((bracket-stack))
    (with-open-file (fstream file :direction :input)
      (on-begin-file item file)
      (do* ((token (next-cpp-token fstream) (next-cpp-token fstream))
	    (ttype (token-type token) (token-type token)))
	   ((null token))
	(ccase ttype
	  (:preprocessor nil)
	  (:enum (parse-enum item fstream))
	  (:left-bracket (push :left-bracket bracket-stack))
	  (:right-bracket (push :right-bracket bracket-stack))
	  (:token nil)))
      (on-end-file item))))

(defclass enum-parser()
  ((enums
    :initform nil
    :accessor enums)
   (current-enum
    :initform nil
    :accessor current-enum)))

(let ((enum-index 0))
  (defmethod on-begin-enum((item enum-parser) name)
    (setf enum-index 0)
    (with-slots (current-enum) item
      (setf current-enum (cons (intern name (find-package :keyword)) nil))))

  (defmethod on-end-enum((item enum-parser))
    (with-slots (enums current-enum) item
      (push (nreverse current-enum) enums)))

  (defmethod on-enum-value((item enum-parser) name value)
    (with-slots (current-enum) item
      (let ((real-value
	     (if value
	       (if (in-ranges (char-int (aref value 0 )) num-ranges)
		   (parse-integer value)
		   (intern value (find-package :keyword)))
	       enum-index)))
	(when (integerp real-value )
	  (setf enum-index (+ enum-index 1)))
	(push (cons (intern name (find-package :keyword))
		    real-value) current-enum)))))

(defmethod on-end-file((item enum-parser))
  (with-slots (enums) item
    (setf enums (nreverse enums))))

(defun enum-value( enum-title enum-name enums )
  (let ((e-list (cdr(assoc enum-title enums))))
    (when e-list
      (do* ((val (cdr(assoc enum-name e-list))(cdr(assoc enum-name e-list)))
	    (enum-name val val))
	   ((or(null val)(integerp val))
	    val )))))
(export 'enum-value)


(defun grab-enumerations( file )
  "Returns the enumerations in form of (enum-group-name enum.value
enum.value) This does not care about namespaces"
  (let ((parser (make-instance 'enum-parser)))
    (parse-cpp-file parser file)
    (enums parser)))
(export 'grab-enumerations)
